home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / info / cad08n11.zip / DIM3D.LSP < prev    next >
Lisp/Scheme  |  1994-02-01  |  5KB  |  182 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;           Advanced AutoLISP Concepts   
  3. ;;           Nov 1993  CADENCE  W.Kramer
  4. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  5. ;;
  6. ;; DIM_UCS  sets up UCS for aligned 
  7. ;; dimensioning in 3D.
  8. ;; Listing 1.
  9. (defun DIM_UCS (EN UCSTYP / EL P1 P2 TMP V)
  10.   (cond 
  11.     ((= (type EN) 'ENAME)
  12.       (setq EL (entget EN))
  13.       (if (= (cdr (assoc 0 EL)) "LINE") ;;line only
  14.          (setq P1 (cdr (assoc 10 EL))
  15.                P2 (cdr (assoc 11 EL))
  16.          )
  17.          (prompt "\n(DIM_UCS) entity not a line")
  18.       )
  19.     )
  20.     ((and (listp (car EN)) (listp (cadr EN)))
  21.       (setq P1 (car EN)
  22.             P2 (cadr EN)
  23.       )
  24.     )
  25.     (t
  26.       (prompt "\n(DIM_UCS) invalid parameter")
  27.     )
  28.   )
  29.   (if (and P1 P2)
  30.     (progn
  31.       ;; P1 should be min Z
  32.       (if (< (caddr P2) (caddr P1))
  33.         (setq TMP P1 P1 P2 P2 TMP)
  34.       )
  35.       ;; V is base vector  
  36.       (setq V (mapcar '- P2 P1))
  37.       ;; Style selection for UCS
  38.       (cond
  39.         ((or (null UCSTYP) 
  40.              (= UCSTYP 0)) ;;angle off XY plane
  41.          (command 
  42.             "_UCS" 
  43.             "_3P" 
  44.             (trans P1 0 1)
  45.             (trans P2 0 1)
  46.             (trans
  47.               (list 
  48.                  (- (car P1) (cadr V))
  49.                  (+ (cadr P1) (car V))
  50.                  (caddr P1)
  51.               )
  52.               0 1)
  53.          );;end COMMAND
  54.         );;end case 0
  55.         ((= UCSTYP 1) ;;perpendicular to XY plane
  56.            (setq 
  57.                DXY 
  58.                (sqrt 
  59.                  (+ 
  60.                    (* (car V) (car V)) 
  61.                    (* (cadr V) (cadr V))))
  62.                UV 
  63.                (list 
  64.                  (/ (car V) DXY) 
  65.                  (/ (cadr V) DXY)) 
  66.          )
  67.          (command 
  68.            "_UCS"
  69.            "_3P"
  70.            (trans P1 0 1)
  71.            (trans P2 0 1)
  72.            (trans
  73.              (list
  74.                (+ (car P1) 
  75.                   (* (car UV) 
  76.                      (caddr V) 
  77.                      -1.0))
  78.                (+ (cadr P1) 
  79.                   (* (cadr UV) 
  80.                      (caddr V) 
  81.                      -1.0))
  82.                (+ (caddr P1) 
  83.                    DXY)
  84.              )
  85.              0 1)
  86.          ) ;;end COMMAND
  87.         );;end case 1
  88.         (t (prompt "\nUCSTYP unknown value!"))
  89.       );;end COND
  90.       'T
  91.     );;end PROGN
  92.   );;end IF
  93. )
  94. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  95. ;; Listing 2
  96. (defun C:DIM3D ()
  97.   (initget 0 "0 1")
  98.   (setq TMP 
  99.     (getkword 
  100.       "\nSelect dimensioning style 0 or 1 <0>: "))
  101.   (if (null TMP) 
  102.     (setq TMP 0) 
  103.     (setq TMP (atoi TMP))
  104.   )
  105.   (setq UCSTYP TMP)
  106.   ;;
  107.   (while (setq TMP (dim_getobj))
  108.     (dim_ucs TMP UCSTYP) ;;set UCS for dimension object
  109.     (command
  110.       "_DIM"
  111.       "_ALI" ;;aligned dimensions
  112.     )
  113.     (if (= (type TMP) 'ENAME)
  114.       (command ;;if entity, construct pick point
  115.          "" 
  116.          (list TMP 
  117.                (cdr (assoc 10 (entget TMP)))))
  118.       (command ;;otherwise, just supply points
  119.          (car TMP) 
  120.          (cadr TMP))
  121.     );;end IF
  122.     (command PAUSE "");;operator select location
  123.     (command "EXIT") ;;terminate DIM command
  124.   );;end WHILE
  125.   (command "_UCS" "_W") ;;set UCS to world on exit
  126.   (princ)
  127. )
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129. ;; Listing 3.
  130. (defun DIM_GETOBJ ( / P1 P2 EN)
  131.   (setq P1 
  132.     (getpoint 
  133.       "\nFirst point [enter for entity select]: "))
  134.   (if (null P1)
  135.     (setq EN 
  136.        (car (entsel "\nSelect LINE entity: ")))
  137.     (setq P2 
  138.        (getpoint P1 "  next point: "))
  139.   );;end IF
  140.   (cond 
  141.     (EN EN) 
  142.     ((and P1 P2) (list P1 P2))
  143.     (t nil)
  144.   );;end COND
  145. )
  146. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  147. ;; Listing 4
  148. (defun C:DIMTEXTFIX ()
  149.   (setq EL 
  150.     (entget 
  151.       (car 
  152.         (entsel "\nPick DIMENSION object"))))
  153.   (if (and EL 
  154.            (= (cdr (assoc 0 EL)) "DIMENSION"))
  155.     (progn
  156.       (setq E2 (tblsearch "BLOCK" 
  157.                           (cdr (assoc 2 EL)))
  158.             E1 (cdr (assoc -2 E2))
  159.       )
  160.       (while E1
  161.         (setq E2 (entget E1))
  162.         (if (= (cdr (assoc 0 E2)) "TEXT")
  163.           (progn
  164.             (setq F1 (cdr (assoc 71 E2))
  165.                   F1 (if (= F1 0) 2 0)
  166.                   E2 (subst 
  167.                         (cons 71 F1) 
  168.                         (assoc 71 E2) 
  169.                         E2)
  170.             )
  171.             (entmod E2)
  172.           );;end PROGN
  173.         );;end IF
  174.         (setq E1 (entnext E1))
  175.       )
  176.       (entupd (cdr (assoc -1 EL)))
  177.     );;end PROGN
  178.     (prompt "\nDid not pick a DIMENSION object!")
  179.   );;end IF
  180.   (princ)
  181. )
  182.